home *** CD-ROM | disk | FTP | other *** search
/ MacWorld UK 2000 March / MW_UK_2000_03.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / menusAndKeys.tcl < prev    next >
Encoding:
Text File  |  1999-07-21  |  26.7 KB  |  865 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "menusAndKeys.tcl"
  6.  #                                    created: 12/9/97 {1:43:22 pm} 
  7.  #                                last update: 06/30/1999 {13:05:50 PM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta, Santa Fe, NM 87501
  11.  #     www: <http://www.santafe.edu/~vince/>
  12.  #  
  13.  # Reorganisation carried out by Vince Darley with much help from Tom 
  14.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  15.  # Alpha is shareware; please register with the author using the register 
  16.  # button in the about box.
  17.  #  
  18.  # 
  19.  #  modified by  rev reason
  20.  #  -------- --- --- -----------
  21.  #  27/11/97 FBO x.x make keys::keyboardChanged use one more item in keyboards
  22.  # ###################################################################
  23.  ##
  24.  
  25. namespace eval menu {}
  26. namespace eval keys {}
  27. namespace eval bind {}
  28.  
  29. ## 
  30.  # -------------------------------------------------------------------------
  31.  # 
  32.  # "menu::bind" --
  33.  # 
  34.  #  Convert a preference of type 'binding' or 'menubinding' into a code
  35.  #  to be inserted into a menu.  Menu-bindings are guaranteed to succeed.
  36.  #  If an ordinary binding contains a prefixChar (e.g. you have bound
  37.  #  ctrl-c followed by ctrl-x to something), then this procedure will
  38.  #  return an empty string, since such bindings cannot appear in menus.
  39.  #  Finally if it is a key-binding and it does not contain a modifier
  40.  #  key, and the key is a normal key (not F1-F12 + few others), then
  41.  #  it will appear in the menu, but the menu will not activate with
  42.  #  that key.  On MacOS, menus can only activate with key-presses
  43.  #  which include a modifier.
  44.  #  
  45.  #  Example usage (from the modeSearchPaths package):
  46.  #  
  47.  #     newPref binding openSelection "<O<B/H" searchPaths
  48.  #     newPref binding sourceHeaderToggle "<O/f" searchPaths
  49.  #   menu::addTo fileUtils \
  50.  #        "[menu::bind searchPathsmodeVars(sourceHeaderToggle) -]" \
  51.  #        "[menu::bind searchPathsmodeVars(openSelection) -]"
  52.  #  
  53.  #  You can adjust these bindings in the package preferences dialog,
  54.  #  but changes will not take effect until you restart Alpha.  Note
  55.  #  that if the user selected menu-incompatible bindings, they would
  56.  #  not operate without the addition of some code to Bind them.  One
  57.  #  would need to add this:
  58.  #  
  59.  #   eval Bind \
  60.  #     [keys::toBind $searchPathsmodeVars(sourceHeaderToggle)] \
  61.  #     file::sourceHeaderToggle
  62.  #   
  63.  #  The optional arg is the rest of the menu item or '-' which means
  64.  #  use the variable name (if a var) or array element (if an array).
  65.  #  
  66.  #  If the optional argument is given, and the menu item therefore
  67.  #  contains a '/', it is considered to be two dynamic items, the
  68.  #  second of which requires the option key to be used.
  69.  #  
  70.  #  Similarly '//' means use shift, '///' means shift-option,
  71.  #  For instance 'set v /W<O ; menu::bind v close/closeAll//closeFloat'
  72.  #  would give you the menu-item for 'close' in the file menu. 
  73.  # -------------------------------------------------------------------------
  74.  ##
  75. proc menu::bind {var {item ""}} {
  76.     upvar \#0 $var a
  77.     if {[regexp {«(.*)»} $a]} { set ret "" } else { set ret $a }
  78.     if {$item != ""} {
  79.     if {$item == "-"} {
  80.         regsub -all {([a-zA-Z_:]+\(|\))} $var {} item
  81.     }
  82.     if {[regexp {/} $item]} {
  83.         set item "<S<E<K$item"
  84.         regsub {///} $item " <S<I<U<K" item
  85.         regsub {//} $item " <S<U<K" item
  86.         regsub {/} $item " <S<I<K" item
  87.         regsub -all {<K} $item $ret ret
  88.     } else {
  89.         append ret $item
  90.     }
  91.     }
  92.     return $ret
  93. }
  94.  
  95. # ◊◊◊◊ flags-menus from prefs ◊◊◊◊ #
  96. # The following four procs allow you to create flag menus with ticks
  97. # very simply.  They adhere to the basic idea of the 'newPref' facility.
  98. proc menu::makeFlagDummy {name {type list}} {
  99.     switch -- $type {
  100.     "array" {
  101.         return [list Menu -n $name -p menu::flagProc {}]
  102.     }
  103.     "list" {
  104.         return [list Menu -m -n $name -p menu::flagProc {}]
  105.     }
  106.     }
  107. }
  108.  
  109. proc menu::makeFlagMenu {name {type list} {var ""} {in_array ""} \
  110.   {nonFlagProc ""} {prologue ""} {epilogue ""}} {
  111.     if {$var == ""} { set var $name }
  112.     switch -- $type {
  113.     "array" {
  114.         global $var menu::flagArray allFlags
  115.         set menu::flagArray($name) \
  116.           [list "array" $var "" $nonFlagProc]
  117.         foreach i [lsort [array names $var]] {
  118.         if {[lsearch -exact $allFlags $i] != -1} {
  119.             lappend items [lindex [list "$i" "!•$i"] [set ${var}($i)]]
  120.         }
  121.         }
  122.         if {[info tclversion] >= 8.0} {
  123.         return [list Menu -t checkbutton -n $name -p menu::flagProc $items]
  124.         } else {
  125.         return [list Menu -n $name -p menu::flagProc $items]
  126.         }
  127.     }
  128.     "list" {
  129.         global $var menu::flagArray
  130.         if {$in_array != ""} {
  131.         set menu::flagArray($name) [list "list" $in_array $var $nonFlagProc]
  132.         global $in_array
  133.         set val [set ${in_array}($var)]
  134.         } else {
  135.         set menu::flagArray($name) \
  136.           [list "list" $var "" $nonFlagProc]
  137.         set val [set $var]
  138.         }
  139.         set i [lsearch -exact [set items [flag::options $var]] $val]
  140.         if {$i != -1} {
  141.         set items [lreplace $items $i $i "!•[lindex $items $i]"]
  142.         }
  143.         if {$prologue != ""} {
  144.         set items [concat $prologue [expr {[llength $items] ? {(-} : ""}] $items]
  145.         } 
  146.         if {$epilogue != ""} {
  147.         set items [concat $items [expr {[llength $items] ? {(-} : ""}] $epilogue]
  148.         }
  149.         if {[info tclversion] >= 8.0} {
  150.         return [list Menu -m -t radiobutton -n $name -p menu::flagProc $items]
  151.         } else {
  152.         return [list Menu -m -n $name -p menu::flagProc $items]
  153.         }
  154.     }
  155.     default {
  156.         error "Other types not yet supported"
  157.     }
  158.     }
  159. }
  160.  
  161. proc menu::stripMetaChars {menuItems} {
  162.     set strippedItems ""
  163.     
  164.     foreach menuItem $menuItems {
  165.     regsub -all {<(B|I|U|O|S|E)} $menuItem "" menuItem
  166.     regsub -all {/.} $menuItem "" menuItem
  167.     regsub -all {!.} $menuItem "" menuItem
  168.     regsub -all {\^.} $menuItem "" menuItem
  169.     regsub -all {…$} $menuItem "" menuItem
  170.     lappend strippedItems $menuItem
  171.     }
  172.     
  173.     return $strippedItems
  174. }
  175.  
  176. proc menu::buildFlagMenu {name args} {
  177.     eval [eval menu::makeFlagMenu [list $name] $args]
  178. }
  179.  
  180. proc menu::flagProc {menu flag} {
  181.     global menu::flagArray flag::procs modifiedArrayElements modifiedVars
  182.     set type [set menu::flagArray($menu)]
  183.     
  184.     set name [lindex $type 1]
  185.     upvar \#0 $name a
  186.     switch -- [lindex $type 0] {
  187.     "array" {
  188.         if {[lsearch -exact [array names a] $flag] == -1} {
  189.         [lindex $type 3] $menu $flag 
  190.         } else {
  191.         set a($flag) [expr {1 - $a($flag)}]
  192.         if {[info exists flag::procs($flag)]} {
  193.             [set flag::procs($flag)] $flag
  194.         }
  195.         message "$menu item '$flag' set to $a($flag)"
  196.         markMenuItem $menu $flag $a($flag)
  197.         lunion modifiedArrayElements [list $flag $name]
  198.         }
  199.     }
  200.     "list" {
  201.         # array entries are indexed by the '2' element.
  202.         if {[set var [lindex $type 2]] == ""} { set var $name }
  203.         
  204.         if {[lsearch -exact [flag::options $var] $flag] == -1} {
  205.         [lindex $type 3] $menu $flag 
  206.         } else {
  207.         if {[set b [lindex $type 2]] == ""} {
  208.             markMenuItem $menu $a off
  209.             set a $flag
  210.             lunion modifiedVars [lindex $type 1]
  211.             message "[lindex $type 1] set to $flag"
  212.         } else {
  213.             markMenuItem $menu $a($b) off
  214.             set a($b) $flag
  215.             lunion modifiedArrayElements [list [lindex $type 2] [lindex $type 1]]
  216.             message "$menu set to $flag"
  217.         }
  218.         markMenuItem $menu $flag on
  219.         if {[info exists flag::procs([lindex $type 1])]} {
  220.             [set flag::procs([lindex $type 1])] $flag
  221.         }
  222.         }
  223.     }
  224.     }
  225. }
  226.  
  227. # ◊◊◊◊ Bindings ◊◊◊◊ #
  228.  
  229. proc menu::bindingsFromArray {arr {include_empty 0}} {
  230.     upvar $arr ar
  231.     set r {}
  232.     foreach a [array names ar] {
  233.     if {[set b $ar($a)] != "" || $include_empty} {
  234.         lappend r "$b$a"
  235.     }
  236.     }
  237.     return $r
  238. }
  239.  
  240. proc bind::fromArray {arr bindarr {unbind 0} {mode {}}} {
  241.     upvar $arr ar
  242.     upvar $bindarr br
  243.     set r {}
  244.     if {$unbind} {
  245.     set bindcmd "unBind"
  246.     } else {
  247.     set bindcmd "Bind"
  248.     }
  249.     foreach a [array names ar] {
  250.     if {[set b $ar($a)] != ""} {
  251.         if {[info exists br($a)]} {
  252.         catch {eval $bindcmd [keys::toBind $b] [list $br($a)] $mode}
  253.         } else {
  254.         beep; message "Bad bind-array entry '$a'"
  255.         }
  256.     }
  257.     }
  258. }
  259.  
  260. ### 
  261.  # -------------------------------------------------------------------------
  262.  # 
  263.  # "keys::verboseKey" --
  264.  # 
  265.  #  Turn a string containing a menu key-code '/x' into a verbose description
  266.  #  of that key.  The optional parameter declares a variable whose value
  267.  #  will be set if the key is a normal key.
  268.  # -------------------------------------------------------------------------
  269.  ##
  270. proc keys::verboseKey {kstr {normal {}}} {
  271.     if {$normal != ""} {upvar $normal n ; set n 0}
  272.     if {![regexp {/(Kpad)(.)} $kstr "" key pad] && ![regexp {/(.)} $kstr "" key]} { return "" }
  273.     switch -regexp -- $key {
  274.     {Kpad} {return "Key pad $pad"}
  275.     {[a-z]} {
  276.         global keys::func
  277.         return [lindex ${keys::func} [expr {[text::Ascii $key] - 97}]]
  278.     }
  279.     "" {
  280.         return "Left"
  281.     }
  282.     "" {
  283.         return "Right"
  284.     }
  285.     "\x10" {
  286.         return "Up"
  287.     }
  288.     "" {
  289.         return "Down"
  290.     }
  291.     " " {
  292.         return "Space"
  293.     }
  294.     default {
  295.         set n 1
  296.         return $key
  297.     }
  298.     }
  299. }
  300.  
  301. set keys::func {Enter Return Tab "Num Lock" F1 F2 F3 F4 F5 F6 F7 F8 F9 F10 \
  302.   F11 F12 F13 F14 F15 Help Delete "Fwd Del" Home End "Page Up" "Page Down"}
  303.  
  304. set keys::ascii {0x03 0x0d 0x09 0 0 0 0 0 0 0 0 0 0 0 \
  305.   0 0 0 0 0 0 0x08 0 0 0 0 0}
  306.  
  307. set keys::bind {Enter 0x24 0x30 Clear F1 F2 F3 F4 F5 F6 F7 F8 F9 F10 \
  308.   F11 F12 F13 F14 F15 Help 0x33 Del Home End Pgup Pgdn}
  309.  
  310. ## 
  311.  # -------------------------------------------------------------------------
  312.  # 
  313.  # "keys::toBind" --
  314.  # 
  315.  #  Turn a menu key-modifier sequence into something suitable for
  316.  #  a 'bind' statement.  Copes with function keys and arrow keys.
  317.  #  
  318.  #  Use a couple of strings to perform shift-mappings, so that although
  319.  #  the binding says it's bound to 'shift-1', say, in fact it must be
  320.  #  bound to '!' (or shift-'!' which are equivalent), since '!' is a 
  321.  #  shifted '1'.
  322.  #  
  323.  #  You can use 'addcode' to add modifiers.  Mostly useful for pairs
  324.  #  of bindings stored in a single pref in which one is an option/shift
  325.  #  modified version of the other.
  326.  # -------------------------------------------------------------------------
  327.  ##
  328. proc keys::toBind {kstr {addcode {}}} {
  329.     if {![regexp {/(Kpad.)$} $kstr "" key] && ![regexp {/(.)} $kstr "" key]} { return "" }
  330.     if {![string match Kpad* $key] && [regexp {[a-z]} $key]} {
  331.     global keys::bind
  332.     set key [lindex ${keys::bind} [expr {[text::Ascii $key] - 97}]]
  333.     } elseif {[set i [lsearch -exact {" " "" "" "\x10" ""} $key]] != -1} {
  334.     set key [lindex {0x31 0x7b 0x7c 0x7e 0x7d} $i]
  335.     } elseif {![string match Kpad* $key]} {
  336.     set key [string tolower $key]
  337.     }
  338.     if {[string length $key] == 1} {
  339.     global keys::mapShiftBindFrom keys::mapShiftBindTo
  340.     if {[regexp {[a-z]} $key] || ![regexp {^<U/} $kstr]} {
  341.         set key '${key}' 
  342.     } elseif {[set i [string first $key ${keys::mapShiftBindFrom}]] != -1} {
  343.         set key '[string index ${keys::mapShiftBindTo} $i]'
  344.     } else {
  345.         #alertnote "Weird key: $kstr, please tell Vince."
  346.         # Note from Vince: I think it's ok just to assume we can
  347.         # bind to the key like this, but it's possible there are
  348.         # some problems on international keyboards.  With a U.S.
  349.         # keyboard we should NEVER get here.
  350.         set key '${key}'
  351.     }
  352.     }
  353.     global keys::international
  354.     if {[info exists keys::international($key)]} {
  355.     set key [set keys::international($key)]
  356.     }
  357.     if {[set a [keys::modifiersTo $kstr$addcode bind]] != ""} {
  358.     return [list $key $a]
  359.     } else {
  360.     return [list $key]
  361.     }
  362. }
  363.  
  364. ## 
  365.  # -------------------------------------------------------------------------
  366.  # 
  367.  # "keys::keyboardChanged" --
  368.  # 
  369.  #  When we change the value of 'keyboards' in the international prefs,
  370.  #  this is called, with the parameter 'keyboards'.
  371.  #  
  372.  #  It is also called at startup, with no parameter.
  373.  #  
  374.  #  Frédéric Boulanger <Frederic.Boulanger@supelec.fr> Nov 27 1997
  375.  #    Added one item to the keyboards items: a list of characters followed
  376.  #    by corresponding key codes.
  377.  #    keys::keyboardChanged now looks for these items and sets 
  378.  #    keys::international to the corresponding key code for each character
  379.  #    in the first list. This is so keys::toBind returns a key code 
  380.  #    instead of a character, which makes Bind only Bind the given character
  381.  #    and leave the shifted char unbound. The problem arose on a french 
  382.  #    keyboard where '{' is '(' <o> and '[' is '(' <os> . Binding '(' <o>
  383.  #    to bind::LeftBrace also binds '(' <os> to bind::LeftBrace, so it was
  384.  #    impossible to type a '['. To avoid this problem, we have to Bind
  385.  #    0x17 <o> to bind::LeftBrace, where 0x17 is the key code for '(' on a
  386.  #    french keyboard.
  387.  #    For other keyboards, I don't know the key codes, so if you have the
  388.  #    same problem with bindings, you may change the definition of your 
  389.  #    keyboard in alphaDefinitions.tcl to solve it.
  390.  # -------------------------------------------------------------------------
  391.  ##
  392. proc keys::keyboardChanged {{flag "startup"}} {
  393.     global keyboards keyboard keys::mapShiftBindFrom keys::mapShiftBindTo \
  394.       modifiedVars oldkeyboard bind::LeftBrace bind::RightBrace keys::international
  395.     if {$oldkeyboard != ""} {
  396.     catch "unBind [keys::toBind ${bind::LeftBrace}] bind::LeftBrace"
  397.     catch "unBind [keys::toBind ${bind::RightBrace}] bind::RightBrace"
  398.     set i 0
  399.     foreach k [lindex $keyboards($oldkeyboard) 4] {
  400.         if {[incr i] % 2} {catch {unset keys::international($k)}}
  401.     }
  402.     catch {unset keys::international}
  403.     hook::callAll removekeyboard $oldkeyboard
  404.     }
  405.     # set new values
  406.     set keys::mapShiftBindFrom [lindex $keyboards($keyboard) 0]
  407.     set keys::mapShiftBindTo [lindex $keyboards($keyboard) 1]
  408.     set bind::LeftBrace [lindex $keyboards($keyboard) 2]
  409.     set bind::RightBrace [lindex $keyboards($keyboard) 3]
  410.     if {[llength $keyboards($keyboard)] >= 5} {
  411.     array set keys::international [lindex $keyboards($keyboard) 4]
  412.     }
  413.     # Bind
  414.     catch "Bind [keys::toBind ${bind::LeftBrace}] bind::LeftBrace"
  415.     catch "Bind [keys::toBind ${bind::RightBrace}] bind::RightBrace"
  416.     # Call anything that's been registered to the new keyboard
  417.     # (Usually a proc to change some menu-bindings).  Use:   
  418.     #   hook::register keyboard "Swiss French" my-proc
  419.     hook::callAll keyboard $keyboard
  420.     if {$oldkeyboard != ""} {
  421.     lappend modifiedVars keyboard
  422.     alertnote "Changing the keyboard may require you to restart\
  423.       Alpha for the bindings to be set correctly."
  424.     }
  425.     set oldkeyboard $keyboard
  426. }
  427.  
  428. proc bind::fromPref {f {un ""}} {
  429.     global flag::binding
  430.     if {[info exists flag::binding($f)]} {
  431.     set m [lindex [set flag::binding($f)] 0]
  432.     if {[set proc [lindex [set flag::binding($f)] 1]] == 1} {
  433.         set proc $f
  434.     }
  435.     namespace eval ::alpha [list catch "${un}Bind [keys::toBind $old] [list $proc] $m"]
  436.     }
  437. }
  438.  
  439.  
  440. ## 
  441.  # -------------------------------------------------------------------------
  442.  # 
  443.  # "keys::modifiersTo" --
  444.  # 
  445.  #  Turn a menu-modifier sequence into something else.  Options are 
  446.  #  'verbose' (a textual description), 'bind' (a binding code-sequence),
  447.  #  and 'menu' which just returns what was given.
  448.  # -------------------------------------------------------------------------
  449.  ##
  450. proc keys::modifiersTo {key type} {
  451.     global alpha::modifier_keys
  452.     set key1 {}
  453.     switch -- $type {
  454.     "verbose" {
  455.         if {[regexp {«(.)»} $key d pref]} {
  456.         if {$pref == "e"} {
  457.             append key1 "escape "
  458.         } else {
  459.             append key1 "ctrl-$pref "
  460.         }
  461.         }
  462.         if {[regexp {<U} $key]} {append key1 "shift-"}
  463.         if {[regexp {<B} $key]} {append key1 "ctrl-"}
  464.         if {[regexp {<I} $key]} {
  465.         append key1 "[lindex ${alpha::modifier_keys} 3]-"
  466.         }
  467.         if {[regexp {<O} $key]} {
  468.         append key1 "[lindex ${alpha::modifier_keys} 1]-"
  469.         }
  470.         return $key1
  471.     }
  472.     "tksym" {
  473.         if {[regexp {«(.)»} $key d pref]} {
  474.         if {$pref == "e"} {
  475.             append key1 "Escape "
  476.         } else {
  477.             append key1 "Control-$pref "
  478.         }
  479.         }
  480.         if {[regexp {<U} $key]} {append key1 "Shift-"}
  481.         if {[regexp {<B} $key]} {append key1 "Control-"}
  482.         if {[regexp {<I} $key]} {
  483.         append key1 "[lindex ${alpha::modifier_keys} 2]-"
  484.         } 
  485.         if {[regexp {<O} $key]} {
  486.         append key1 "[lindex ${alpha::modifier_keys} 0]-"
  487.         }
  488.         return $key1
  489.     }
  490.     "bind" {
  491.         if {[regexp {<U} $key]} {append key1 "s"}
  492.         if {[regexp {<B} $key]} {append key1 "z"}
  493.         if {[regexp {<I} $key]} {append key1 "o"}
  494.         if {[regexp {<O} $key]} {append key1 "c"}
  495.         if {[regexp {«(.)»} $key d pref]} {
  496.         append key1 $pref
  497.         }
  498.         if {$key1 != ""} {
  499.         return "<${key1}>"
  500.         } else {
  501.         return ""
  502.         }
  503.     }
  504.     "menu" {
  505.         if {[regexp {«(.)»} $key d pref]} {
  506.         return ""
  507.         } else {
  508.         return $key
  509.         }
  510.     }
  511.     }
  512. }
  513.  
  514. ## 
  515.  # -------------------------------------------------------------------------
  516.  # 
  517.  # "keys::bindToMenu" --
  518.  # 
  519.  #  Doesn't yet cope with function keys etc, nor 0x31 type bindings,
  520.  #  nor prefixChars (which can't go in a menu anyway).
  521.  # -------------------------------------------------------------------------
  522.  ##
  523. proc keys::bindToMenu {i} {
  524.     regexp {'(.)'[ \t]*<([^>]+)>} $i d key mods
  525.     set key "/[string toupper $key]"
  526.     if {[regexp {s} $mods]} {append key "<U"}
  527.     if {[regexp {z} $mods]} {append key "<B"}
  528.     if {[regexp {o} $mods]} {append key "<I"}
  529.     if {[regexp {c} $mods]} {append key "<O"}
  530.     return $key
  531. }
  532.     
  533. ## 
  534.  # -------------------------------------------------------------------------
  535.  # 
  536.  # "keys::findPrefixChars" --
  537.  # 
  538.  #  This proc is rather slow, since it has to scan an enormous list of
  539.  #  bindings.  However since it is only used from the dialog below,
  540.  #  that doesn't matter too much (i.e. it is quick enough on my machine).
  541.  # -------------------------------------------------------------------------
  542.  ##
  543. proc keys::findPrefixChars {} {
  544.     set menu ""
  545.     foreach i [keys::findBindingsTo "prefixChar"] {
  546.     if {![regexp {'(.)'[ \t]*<z>} $i d key]} {
  547.         beep; message "A bad prefix char has been defined: Bind $i prefixChar, this will not work."
  548.     } else {
  549.         lappend menu [string toupper $key]
  550.     }
  551.     }
  552.     return $menu
  553. }
  554.  
  555. proc keys::findBindingsTo {to {mode ""} {lines 0}} {
  556.     if {$mode == "*"} { set mode "(\\w+)?" }
  557.     set t [bindingList]
  558.     set pref ""
  559.     while {[regexp -indices "\rBind(\[^\r\]+) $to *${mode} *\r" $t d idx]} {
  560.     if {$lines} {
  561.         lappend pref [string trim [eval string range [list $t] $d]]
  562.     } else {
  563.         lappend pref [string trim [eval string range [list $t] $idx]]
  564.     }
  565.     set t [string range $t [lindex $idx 1] end]
  566.     }
  567.     return $pref
  568. }
  569.  
  570. proc keys::findBindingsOf {of {mode ""}} {
  571.     if {$mode == "*"} { set mode "(\\w+)?" }
  572.     set t [bindingList]
  573.     set pref ""
  574.     while {[regexp -indices "\rBind[quote::WhitespaceReg " ${of} "](\[\\w:\]+) *${mode} *\r" $t l idx]} {
  575.     lappend pref [string trim [eval string range [list $t] $l]]
  576.     set t [string range $t [lindex $idx 1] end]
  577.     }
  578.     return $pref
  579. }
  580.  
  581. proc keys::unsetBinding {v {mode ""}} {
  582.     foreach i [keys::findBindingsOf $v $mode] {
  583.     regsub {' '} $i {0x31} i
  584.     eval "un${i}"
  585.     }
  586. }
  587.  
  588. proc keys::bindPackage {pkg} {
  589.     global ${pkg}modeVars flag::type flag::binding
  590.     foreach v [array names ${pkg}modeVars] {
  591.     if {[info exists flag::type($v)] && [set flag::type($v)] == "binding"} {
  592.         if {[info exists flag::binding($v)]} {
  593.         set m [lindex [set flag::binding($v)] 0]
  594.         if {[set proc [lindex [set flag::binding($v)] 1]] == 1} {
  595.             set proc $v
  596.         }
  597.         namespace eval ::alpha [list catch "Bind [keys::toBind [set ${pkg}modeVars($v)]] [list $proc] $m"]
  598.         }
  599.     }
  600.     }
  601. }
  602.  
  603. # ◊◊◊◊ Key presses ◊◊◊◊ #
  604. namespace eval key {}
  605.  
  606. proc key::optionPressed {{m ""}} {
  607.     if {$m == ""} {set m [getModifiers]}
  608.     return [expr {$m & 72}]
  609. }
  610. proc key::shiftPressed {{m ""}} {
  611.     if {$m == ""} {set m [getModifiers]}
  612.     return [expr {$m & 34}]
  613. }
  614. proc key::controlPressed {{m ""}} {
  615.     if {$m == ""} {set m [getModifiers]}
  616.     return [expr {$m & 144}]
  617. }
  618. proc key::cmdPressed {{m ""}} {
  619.     if {$m == ""} {set m [getModifiers]}
  620.     return [expr {$m & 1}]
  621. }
  622.  
  623. namespace eval prompt {}
  624. ## 
  625.  # -------------------------------------------------------------------------
  626.  # 
  627.  # "prompt::getAKey" --
  628.  # 
  629.  #  'getChar' is modified by ctrl and option, so if the user presses one
  630.  #  of them, we have to request the key again.  Also if the user pressed
  631.  #  shift and the key wasn't A-Z, then we also have to ask again.  Finally
  632.  #  if the key pressed was a non-ascii one, we have to select from a menu.
  633.  #  
  634.  #  This function is an alternative to 'dialog::getAKey'.  Hence it takes
  635.  #  the same parameters, except it ignores some of them.
  636.  #  
  637.  #  Doesn't currently deal with the 'for_menu' flag which it should.
  638.  # -------------------------------------------------------------------------
  639.  ##
  640. proc prompt::getAKey {{name ""} {keystr ""} {for_menu 1}} {
  641.     beep ; message "Press the key and modifiers"
  642.     set char [string toupper [getChar]]
  643.     set mod [getModifiers]
  644.     if {$mod & 0xd8 || ($mod & 0x22) && ![regexp {[A-Z]} $char]} {
  645.     beep; message "Please press the key again, this time without modifiers."
  646.     set char [string toupper [getChar]]
  647.     }
  648.     if {![regexp {[][=A-Z0-9`\\';,./-]} $char]} {
  649.     global keys::ascii keys::func
  650.     set ascii [text::Ascii $char]
  651.     if {$ascii > 27 && $ascii < 32} {
  652.         set char [lindex {"" "" "\x10" ""} [expr {$ascii - 27}]]
  653.     }
  654.     set i 0
  655.     foreach k ${keys::ascii} { 
  656.         if {[expr {$k == $ascii}]} { 
  657.         set char [text::Ascii [expr {$i + 97}] 1]
  658.         break
  659.         }
  660.         incr i
  661.     }
  662.     if {$i == [llength ${keys::ascii}]} {
  663.         set char [dialog::optionMenu \
  664.           "This procedure cannot isolate which key that was.  You'll have to select it manually" ${keys::func} "" 1]
  665.         set char [text::Ascii [expr {$char + 97}] 1]
  666.     }
  667.     }
  668.     set res [keys::modToMenu $mod $char]
  669.     if {!$for_menu} {
  670.     beep; message "If there is a prefix-char, hit that now (without the ctrl-key) else return."
  671.     set char [string toupper [getChar]]
  672.     if {[text::Ascii $char] == 27} { set char "e" } 
  673.     if {[regexp -nocase {[a-z]} $char]} {append res "«$char»"}
  674.     }
  675.     return $res
  676. }
  677.  
  678. ## 
  679.  # cmdKey                      = 0x01,
  680.  # shiftKey                    = 0x02,
  681.  # alphaLock                   = 0x04,
  682.  # optionKey                   = 0x08,
  683.  # controlKey                  = 0x10,
  684.  # rightShiftKey               = 0x20,
  685.  # rightOptionKey              = 0x40,
  686.  # rightControlKey             = 0x80,
  687.  ##
  688. # 'char' must be upper case, if it really is a char.
  689. proc keys::modToMenu {mod {char ""}} {
  690.     if {$char != ""} {
  691.     set t "/${char}"
  692.     } else {
  693.     set t ""
  694.     }
  695.     # cmd
  696.     if {[expr {$mod & 1}]} { append t "<O" }
  697.     # shift
  698.     if {[expr {$mod & 2 |  $mod & 32}]} { append t "<U" }
  699.     # option
  700.     if {[expr {$mod & 8 | $mod & 64}]} { append t "<I" }
  701.     # ctrl
  702.     if {[expr {$mod & 16 | $mod & 128}]} { append t "<B" }
  703.     return $t
  704. }
  705.  
  706. proc global::specialKeys {} {
  707.     global keys::specialBindings keys::specialProcs modifiedArrVars
  708.     # unbind old set
  709.     bind::fromArray keys::specialBindings keys::specialProcs 1
  710.     
  711.     if {[hook::callAll specialKeys *]} {
  712.     # rebind old set and return
  713.     bind::fromArray keys::specialBindings keys::specialProcs
  714.     return
  715.     }
  716.     
  717.     if {[catch {dialog::arrayBindings "Special keys" keys::specialBindings}]} {
  718.     # cancelled so rebind old set
  719.     bind::fromArray keys::specialBindings keys::specialProcs
  720.     return
  721.     }
  722.     # Bind new set
  723.     bind::fromArray keys::specialBindings keys::specialProcs
  724.     # perhaps do something else?
  725.     lappend modifiedArrVars keys::specialBindings
  726. }
  727.  
  728.  
  729. ## 
  730.  # -------------------------------------------------------------------------
  731.  # 
  732.  # "alpha::basicKeyBindings" --
  733.  # 
  734.  #  Bind all the obvious stuff, so cursor keys etc actually work!
  735.  # -------------------------------------------------------------------------
  736.  ##
  737. proc alpha::basicKeyBindings {} {
  738.     Bind Left  backwardChar
  739.     Bind Left <c> beginningOfLine
  740.     Bind Left <s> backwardCharSelect
  741.     Bind Left <sc> beginningLineSelect
  742.     Bind Left <z> {scrollLeftCol 15}
  743.     Bind Left <o> backwardWord
  744.     Bind Left <os> backwardWordSelect
  745.     
  746.     Bind Right  forwardChar
  747.     Bind Right <c> endOfLine
  748.     Bind Right <s> forwardCharSelect
  749.     Bind Right <sc> endLineSelect
  750.     Bind Right <z> {scrollRightCol 15}
  751.     Bind Right <o> forwardWord
  752.     Bind Right <os> forwardWordSelect
  753.     
  754.     Bind Up        previousLine
  755.     Bind Up <s>    prevLineSelect
  756.     Bind Up <c>    beginningOfBuffer
  757.     Bind Up <sc>   beginningBufferSelect
  758.     Bind Up <z>    scrollUpLine
  759.     Bind Up <o>    scrollUpLine
  760.     
  761.     Bind Down      nextLine
  762.     Bind Down <c>  endOfBuffer
  763.     Bind Down <s>  nextLineSelect
  764.     Bind Down <sc> endBufferSelect
  765.     Bind Down <z>  scrollDownLine
  766.     Bind Down <o>  scrollDownLine
  767.     
  768.     # Keypad definitions
  769.     Bind KPad4     backwardWord                 
  770.     Bind KPad4 <c> backwardDeleteWord 
  771.     Bind KPad6     forwardWord                 
  772.     Bind KPad6 <c> deleteWord 
  773.     Bind Clear     toggleNumLock
  774.     # Never Bind Keypad /
  775.     # Never Bind Keypad *
  776.     Bind KPad0     nextWindow
  777.     Bind KPad0 <s> prevWindow
  778.     Bind KPad+     swapWithNext
  779.     Bind KPad-     prevWindow
  780.     Bind KPad0       pageBack
  781.     # Bind Enter   pageForward
  782.     Bind Enter       briefThing
  783.     Bind Kpad1     prevFunc
  784.     Bind Kpad3     nextFunc
  785.     Bind KPad.     endOfBuffer                 
  786.     Bind KPad5     exchangePointAndMark     
  787.     Bind KPad7     backwardDeleteWord         
  788.     Bind KPad9     deleteWord                 
  789.     
  790.     Bind Help       alphaHelp                     
  791.     Bind Home       beginningOfBuffer             
  792.     Bind End        endOfBuffer                 
  793.     Bind Pgup       pageBack                     
  794.     Bind Pgdn       pageForward                  
  795.     # The first two of these cause problems with dead-keys, whereas the
  796.     # latter two work ok!  Thanks Dominique
  797.     #Bind Del        deleteChar                 
  798.     #Bind 0x33        backSpace
  799.     ascii 0x08  backSpace
  800.     ascii 0x7f  deleteChar
  801. }
  802.  
  803. ## 
  804.  # -------------------------------------------------------------------------
  805.  # 
  806.  # "alpha::keyBindings" --
  807.  # 
  808.  #  Bind some 'standard' alpha key-bindings
  809.  # -------------------------------------------------------------------------
  810.  ##
  811. proc alpha::keyBindings {} {
  812.     Bind Del    <z> forwardDeleteWhitespace
  813.     Bind 0x33   <z> forwardDeleteWhitespace
  814.     Bind 0x33  <sz> forwardDeleteUntil
  815.     
  816.     Bind 't' <z>     insertToTop        
  817.     Bind 'z' <z>     pageBack
  818.     Bind '\ ' <z>     setMark
  819.     Bind '1' <z>    execAbbrev
  820.     
  821.     # Another control prefix.
  822.     Bind 'q' <z>     prefixChar
  823.     Bind 't' <Q>    shrinkHigh
  824.     Bind 'b' <Q>    shrinkLow
  825.     Bind 'l' <Q>    shrinkLeft
  826.     Bind 'r' <Q>    shrinkRight
  827.     Bind 'c' <Q>    chooseAWindow
  828.     Bind 'h' <Q>    winhorizontally
  829.     Bind 'i' <Q>    iconify
  830.     Bind 'n' <Q>    nextWindow
  831.     Bind 'o' <Q>    bufferOtherWindow
  832.     Bind 'p' <Q>    prevWindow
  833.     Bind 's' <Q>    swapWithNext
  834.     Bind 'a' <Q>    wintiled
  835.     Bind 'v' <Q>    winvertically
  836.     Bind 'f' <Q>    shrinkFull
  837.     Bind '2' <Q>    splitWindow
  838.     
  839.     Bind '\ ' <o>    oneSpace
  840.     Bind Esc    startEscape
  841.     Bind 'f' <cz>     freeMem
  842.     Bind 'h' <z>    hiliteWord
  843.     
  844.     Bind 'm' <X>    matchingLines 
  845.     Bind 's' <ze> regIsearch
  846.     Bind 'l' <C> dividingLine
  847.     
  848.     # global binding for CR
  849.     Bind '\r'       bind::CarriageReturn
  850.     Bind   F1         bind::Completion     
  851.     Bind '\[' <zs>  normalLeftBrace
  852.     Bind '\]' <zs>  normalRightBrace
  853.     # Useful for C-like-modes
  854.     Bind '\;'      bind::electricSemi
  855.     Bind '\;' <z> "typeText {;}"
  856.     Bind 'l' <z> centerRedraw
  857.     Bind 'l' <oz> refresh
  858. }
  859.  
  860.  
  861.  
  862.  
  863.  
  864.  
  865.